perm filename NOTWRT.F4[1,LCS]2 blob sn#084616 filedate 1974-01-30 generic text, type T, neo UTF8
	SUBROUTINE NOTWRT
	IMPLICIT INTEGER(A-Q,S-Z)
	COMMON/DL/IXRX,M,AA
	COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
	DIMENSION SU(250),RACNT(52),RDOT(7),XAC(6)
	REAL DIS,PWDS,CENTR,POS,STFF
	COMMON /STF/RSTFAC(8),RSTJC
	COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
	COMMON/PLTR/PLT,RHT,DIS/XRN/RN(4000)/POSI/STFF(8),JJB,POS
	COMMON/NW/FILL(7),RNOTE(24)
	COMMON /NU/NUMQ(44),RNUMS(327),RACCI(32),NACCI(3)
C   FOR NOTE DRAWING
	EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJD,RJQ(2))
	1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
	1,(JK,JQ(9)),(JF,JQ(4)),(RJE,RJQ(3)),(SU(1),RN(3001))
	1,(RJH,RJQ(6)),(RJG,RJQ(5))
	DATA RACNT/4.0,1000.005,17.0,0.105, 8.0,1003.0, 7.014, 11.0
	1,13. ,1000. ,0.010,14.01,14. ,17. ,1001.018,7. ,13.018,27.,
	1 1004., 4.002, 6.004, 8.004,10.002,10., 8.102,6.102,4.
	1,32.0,1000.0,14.0,1007.007,7.107, 43.0,1012.01,11.006,9.003
	1, 7.001, 5.0, 9.002, 13.006, 15.01, 10.004, 13.009, 52.0,
	1 1002.008,3.003, 5.001, 8.0, 10.0, 13.001, 15.003, 16.008/
	DATA RDOT/1000.0, 0.103, 1.0, 1.103, 2.0, 2.103,0/
	1 , R5/5.0/, R66/66.0/, R72/72.0/,R18/18.0/,RSTM/14.54/
	1 ,XAC/9,14,18,28,33,44/
C   ALL DATA NUMS OVER 90 GIVE INVISIBLE VECTORS
CC	RACTX=0
CC	RSTJC=RSTFAC(JC+4)
	RST3=3.*RSTJC
	RST4=4.*RSTJC
CC	RST13=13.*RSTJC
	RST7=7.*RSTJC
	RSTX=RSTJC
C  FOR MINIS AT 245

1	CENTR=POS-R18*RSTJC+AMOD(RJD,100.0)*RST7
C   'CENTR' IS VERTICAL PLACEMENT
	IF(JA.EQ.9)GO TO 90
	RMINI=RSTJC
C  OR SHOULD THIS ONLY BE IN NOTES, ETC?  15/9/72

	IF(JA.EQ.101)GO TO 110
	RJB=JB
	RINV=1
551	GO TO (11,20,30,241,50,242,70,80,90,11,30,80),JA
CC	IF(JA.EQ.11)GO TO 30
	IF(JA.EQ.30)GO TO 571
C   FOR BEAMS.
90	CALL ITMSUB
	RETURN

20	IF(JE.GT.1)RJD=RJD-2
	RA=RJD
	RJG=RJF*10.
C  FOR DOTS
202	CALL REST
	IF(JE.GT.1)GO TO 200
	IF(RJG.EQ.0)RETURN
201	L=14
	IF(JE)L=19
	JB=JB+L*RSTJC
	RJD=8.+RA
	JA=6
	JE=7
C   IF P6=1 THE REST IS DOTTED
	GO TO 1
200	JE=JE-1
C  FOR MULTIPLE TAILS ON 16TH REST, ETC.
	RJD=RJD+2.
	RJB=RJB+RST4
	GO TO 202
80	CALL SLUR
57	RETURN

C  FOR TREMOLO SLASHES
571	RJB=RJB+1
	RX=14.*RSTJC
	RJX=CENTR+RST7
	RJY=RJX-RX
	IF(JE.EQ.10)GO TO 42
	CALL EXCH(RJX,RJY)
	RJB=RJB-RX+1
42	RX=RJB+26*RSTJC
	DO 40 K=1,JF
	DO 41 L=0,2
	RA=L*RSTJC
	CALL LINES(RJB,RJX+RA,3)
41	CALL LINES(RX,RJY+RA,2)
	RJX=RJX+RST7
40	RJY=RJY+RST7
	RETURN

C FOR USER-DRAWN LIBRARY OF SYMBOLS
30	CALL CLEFS
	RETURN
291	RJB=RJB+8.*RSTJC
	IF(RINV)CENTR=CENTR-RST3
C  REMOVE '8' LATER
	CENTR=CENTR+2*RSTJC

29	RJX=RJB
	RJY=CENTR+RSTJC
108	CALL RDRAW(1,7.0,RDOT,RSTJC,RJX,RJY,RSTJC)
	IF(JA.EQ.1.OR.RJG.GE.20.)GO TO 290
	RB=POS+52.*RSTJC
	IF(RJY.NE.RB)GO TO 6241
C   WHERE IS RB USED LATER?
	RJY=RJY-12*RSTJC
	GO TO 108
C  ABOVE FOR DOTS
290	RJG=RJG-10.
	IF(RJG.LT.10.)GO TO 1342
	RJX=RJX+RSTJC*13.
	GO TO 108


C  FOR LEDGER LINES
70	JK=JD
C   NOTE #
170	RJW=RJB-9.*RMINI
	RJZ=RJB+22.*RMINI
CC	RJZ=RJB+24.*RMINI
	IF(JK)GO TO 71
	JX=JK
	JY=13
C********* 18/9/72
	GO TO 711
71	JX=-JK
	JY=JK*2+3
711	RX=POS-18*RSTJC+RST7*JY
C********* 18/9/72
	IF(JF)RJZ=RJZ+2*RMINI
C126	IF(PLT.EQ.-3)GO TO 1126
C  FOR 2-PASS PLOTTING
C   ******* ABOVE IS NOT USED, 15/9/72
CC	IF(PLT.EQ.-2)PLT=-4
126	CALL LINES(RJW,RX,3)
	CALL LINES(RJZ,RX,2)
CC	IF(PLT.EQ.-4)PLT=-2
1126	IF(JX.EQ.1)GO TO 1122
	RX=RX+RSTJC*14.
	JX=JX-1
	GO TO 126
1122	IF(JA.EQ.7)RETURN
	JI=-1
	GO TO 1121

11	STEM=JE/10

C  NOTES****
C	RACTX=ABS(AMOD(RJF,1.0))*10.
	RJF=ABS(AMOD(RJF,1.0))*10.
C   RJF WILL HAVE ACCENT CODE # (.7=DOT, ETC.)
1011	RG=19.0
	KL=1
CC	IF(PLT.NE.-1.OR.IXRX.NE.0)RG=14.
	IF(PLT.NE.-1)RG=14.
C  FOR 2-PASS PLOTTING
	IF(IABS(JD).LT.100)GO TO 1221
	IF(IABS(JD).LT.200)GO TO 1012
	RG=24.0
	KL=20
C  FOR DIAMOND NOTES.
	GO TO 1013
1012	RMINI=.6*RSTJC
C  FOR RMINI NOTES
1013	JD=MOD(JD,100)
	RJD=RJD-100.
	IF(RJD.GT.160.)GO TO 1013
C  FOR MINI TAILS AND ACCIS. ETC.
1221	JY=IABS(JF)
	IF(JY.LT.10)GO TO 2221
C P6 FOR HOMING TO RIGHT (10) OR LEFT (20) OF STEM(10=UP, 20=DOWN)
C P6<0 = WHITE NOTE
	RQ=RSTM
	IF(JF)RQ=RQ+1.66
C GETS WIDTH OF NOTE DISPLACEMENT
	IF(JY.EQ.20)RQ=-RQ
	RJB=RJB+RQ*RMINI
2221	IF((JD.GT.1.AND.JD.LT.13).OR.JI.NE.0)GO TO 1121
C   ARE THERE LEDGER LINES?
	JK=(JD+1)/2-6
	IF(JK)JK=-((3-JD)/2)
	GO TO 170
C  IF JF≠0 NOTE IS FILLED IN
1121	IF(JF.GE.0.AND.KL.EQ.1)GO TO 125
	CALL RDRAW(KL,RG,RNOTE,RMINI,RJB,CENTR,RMINI)
	GO TO 123
125	IF(PLT)GO TO 1251
	CALL LINES(RJB,CENTR,3)
CC	JK=3
	RG=4.0
	GO TO 1253
1251	CALL NOIR(RMINI)
	GO TO 123

1253	RG=RMINI*RG
	RA=RJB+RG
CC	DO 1252 K=1,7,JK
	DO 1252 K=1,7,3
	RB=FILL(K)*RMINI
	CALL LINES(RA,CENTR+RB,2)
	CALL LINES(RA,CENTR-RB,2)
1252	RA=RA+RG
C   ABOVE IS NEW NOTES ROUTINE

123	RJE=RJE-JE
C  RJE=STEPS TO LEFT FOR ACCID. (.1=1 STEP)
	IF(STEM.EQ.0)GO TO 1242
128	JG=MOD(JG,10)
	RG=(JG-1)*14
	IF(RG)RG=0
	IF(RJH.GE.999)RJH=0
C   NO EXTEN. OF STEM?
	RH=RJH*RST7
C  STEM EXTENSIONS ARE BY NOTE #S
	IF(STEM.NE.2)GO TO 1280
	RJX=RJB
C  FOR STEM DOWN (=2)
	RG=-RG-48.
	RH=-RH
	L=20
	RJY=3.
	RJD=RJD-3.7-RJH
C RJD IS USED IN SUBR. TAIL   - RJH IS STEM EXTENSION.
	RJW=-2
	RA=1.
	GO TO 129
C  NEXT IS FOR STEM UP.
1280	RJX=RSTM
	RJW=2
C  FOR VERT. SPACING OF MULTIPLE TAILS
	RJD=RJD-2+RJH
C  2 ABOVE AND 3.7 BEFORE ARE BECAUSE ORIG. POS. OF TAIL DRWING IS OFF.
	IF(JF.NE.0)RJX=16.2
C  FOR HALF NOTES
	RJX=RJX*RMINI+RJB
	RG=RG+48.
	L=10
	RJY=-3.
	RA=-1.
129	RJZ=CENTR+RH+RG*RMINI
	IF(RMINI.NE.RSTJC)RJW=RJW*.6
CC	IF(PLT.EQ.-3)GO TO 227
CC	IF(PLT.EQ.-2)PLT=-4
	CALL LINES(RJX,CENTR,3)
	CALL LINES(RJX,RJZ,2)
CC	IF(PLT.EQ.-4)PLT=-2
227	JE=JE-L
C   JE HAS ACCID. # NOW
	IF(JG.EQ.0)GO TO 1242
C   JUMP IF NO TAILS
127	CALL TAIL(RJX,RA,RMINI)
1028	JG=JG-1
	IF(JG.EQ.0)GO TO 327
	RJD=RJD+RJW
C  MOVES CENTR UP OR DOWN FOR NEXT TAIL
	GO TO 127
327	IF(JJ.EQ.0)GO TO 1242
	RJY=RJZ-19*RSTJC
	RJZ=RJZ-RST4
CC	IF(RJX.NE.RJB-1)GO TO 1327
	IF(RA.LT.0)GO TO 1327
C  NEXT IS FOR STEM DOWN SLASH
	RJY=RJZ+23*RSTJC
	RJZ=RJZ+RST7
1327	RJX=RJX-RST7
	CALL LINES(RJX,RJY,3)
	CALL LINES(RJX+17.0*RSTJC,RJZ,2)
C  FOR SLASH ON GRACE NOTE TAIL
1242	IF(RJG.LT.10.)GO TO 1342
C  FOR DOTTED NOTE-- P7>9 
	RJX=RJB+(24.+AMOD(RJG,1.0)*59.6)*RMINI
	RJY=CENTR+RSTJC
	IF(MOD(JD,2).NE.0)RJY=RJY+RST7
	GO TO 108
1342	RJAC=RJB
C   TO SAVE POS. OF NOTE FOR ACCENT
	RJB=RJB-RJE*59.6*RMINI
C  TO SPACE OUT ACCIDS.
	IF(RMINI.NE.RSTJC)RSTJC=.7*RSTJC
C   ↑↑↑↑		  ↑↑↑↑↑ WAS RMINI
C********* 18/9/72
242	IF(JE.GE.0)GO TO 2421
	RINV=-RINV
	JE=-JE
C  NOW THAT 0 IS NOT USED FOR DOTS THE ABOVE 3 LINES COULD BE CHNGD
C********** LAST # WAS 281?
C b,#,NAT, ACC ∧, ACC >, FERMATA, DOT, REP MEAS., DASH
2421	RH=14
	IF(JA.NE.6)GO TO 211
	STEM=0
C   FOR MISC. ITEMS
210	IF(IABS(JD).LT.100)GO TO 3241
	JD=MOD(JD,100)
	RSTJC=.7*RSTJC
3241	JEX=-1
C FOR 2 MARKS AT ONCE.
1241	IF(JE.GE.11)GO TO 28
	GO TO (211,211,211,28,28,222,249,60,27,27),JE
	RETURN
C  ERROR TRAP (I.E. JE=0)

241	CALL LINES(RJB,CENTR,3)
	GO TO 210

2422	IF(RJF.EQ.0)RETURN
CC2422	IF(RACTX.EQ.0)RETURN
	RJB=RJAC
CC	RJF=RJF+.001
	JE=(RJF+.001)*100.
1249	IF(MOD(JE,10).GT.3)GO TO 249
	JE=JE/10
	IF(JE.GT.30)GO TO 1249
C EXTRACTS ACCENT NUMBERS FROM DECIMALS IN P6.
CC	IF(RJF.LT.4.)RJF=RJF*10.
CC	IF(RACTX.LT.4.)RACTX=RACTX*10.
CC	IF(X.NE.0)JE=JE*10+X
CC249	RX=0
CC	IF(JE.EQ.7)RX=6.7
CC	IF(JE.EQ.12.OR.JE.EQ.13)RX=5
CC	IF(JE.EQ.11)RX=2
CC	RJB=RJB+RX*RSTJC
C  ↑↑↑↑		  ↑↑↑↑↑ WAS RMINI
C   WHAT ABOUT MINI ACCENTS?
249	IF(JE.GT.30)GO TO 28
	IF(JE.GT.10)GO TO 246
	IF(JA.NE.1)GO TO 250
	RH=8
	RB=14.
	IF((JE.NE.7.AND.JE.NE.9).OR.MOD(JD,2).EQ.0)GO TO 244
	IF((STEM.LE.1.AND.JD.LT.5).OR.((STEM.EQ.2.OR.STEM.EQ.0)
	1 .AND.JD.GT.9))GO TO 244
	RB=21
C   PUTS ACCENT DOWN OR UP 1 SPACE. AVOIDS PUTTING DOT OR DASH ON LINE
244	IF(STEM.EQ.1.OR.(STEM.EQ.0.AND.JD.LT.7))RB=-RB
	IF(JE.NE.6)GO TO 245
	IF(JD.LT.9.AND.STEM.EQ.2)GO TO 247
	IF(JD.GT.4.AND.STEM.EQ.1)GO TO 252
245	CENTR=CENTR+RB*RSTX
250	IF(JE.GT.10.OR.JE.LT.6)GO TO 247
	JA=6
	IF(JE.NE.7)GO TO 253
C   7=DOT
	RXX=RJB
	RJB=RJB+6.7*RMINI
C  CENTERS THE DOT
	GO TO 29
253	IF(JE.EQ.9)GO TO 271
C   9=DASH
251	IF(RB.LT.0)RINV=-RINV
C   FIX THIS!!!!  FOR BOWINGS, ETC.
222	CALL FERMTA(RINV)
	GO TO 5241
252	RX=POS
248	CENTR=RX
	GO TO 251
246	IF(STEM.EQ.1)RB=70.
	IF(STEM.EQ.2)RB=21.
C  CHANGE R66 AND R72 TO NUMS WHEN RIGHT ONES ARE FOUND.
	GO TO 245
247	RX=POS+R72*RSTJC
	IF(JE.EQ.6.OR.JE.EQ.26)GO TO 248
C  26 IS NEW NUMB FOR FERMATA. TAKE OUT 6 EVENTUALLY.
	IF(JA.EQ.1.AND.JE.GT.10.AND.CENTR.LT.RX)CENTR=RX
CC	JEX=-1
28	IF(JE.LT.30)GO TO 281
	JEX=MOD(JE,10)
C  JEX SAVES NEXT MARK.
	IF(JEX.LT.4)JEX=0
	JE=JE/10
	IF(JE.GT.30)RETURN
C  WON'T READ 415 ETC. (CORRECT=154)
C DOES BOTTOM MARK FIRST, THEN TOP.
	CALL EXCH(JEX,JE)
C  PUTS UPBOW, DNBOW, ETC. ABOVE STACC., ETC.
	IF(JA.EQ.1)GO TO 249
	GO TO 1241
281	X=1
	IF(JE.NE.4)GO TO 228
	X=5
	RJB=RJB+.5*RSTJC
	GO TO 328
CC	IF(JE.EQ.11)X=9
CC	IF(JE.EQ.12)X=14
CC	IF(JE.EQ.13)X=18
CC	IF(JE.EQ.14)X=28
CC	IF(JE.EQ.15)X=33
CC	IF(JE.EQ.16)X=44
228	IF(JE.GT.10)X=XAC(JE-10)
C   X IS POINTER IN RACNT ARRAY
328	RA=RMINI
C   OR RSTJC?
	IF(RINV.LT.0.OR.(STEM.EQ.1.AND.JE.EQ.4))RA=-RA
	CALL RDRAW(X+1,RACNT(X),RACNT,RA,RJB,CENTR,RMINI)
C              PTR, WDCNT, ARRAY,Y MULT,HOR ADD,VERT ADD, X,Y,MULT
C  IN ARRAY, 33.012 WOULD BE X=33, Y=12.  101.123 IS X=-1, Y=-23.
	GO TO 5241
4241	JJJ=JE
	JE=JEX
	JEX=-1
	IF(JA.NE.1)GO TO 7241
	IF(JE.GT.10)GO TO 246
	IF(JE.EQ.7.AND.JJJ.NE.9)GO TO 249
7241	RXX=RH*RMINI
	IF(STEM.EQ.1)RXX=-RXX
	CENTR=CENTR+RXX
	IF(JE.EQ.26)JE=6
C  TEMPORARY?? FIX
	GO TO 1241
C >=5,  ∧=4
27	RJB=JB
271	CALL LINES(RJB,CENTR,3)
C  DASHES
	CALL LINES(RJB+RSTJC*14.,CENTR,2)
5241	IF(JEX.GT.0)GO TO 4241
C JEX IS FOR DOUBLE MARKS.  (WHAT ABOUT DOT POSITION.)
	RETURN
6241	RJB=RXX
C  RESET RJB AFTER A DOT.
	GO TO 5241
211	IF(JE.EQ.0)GO TO 2422
	IF(JE.GT.3)GO TO 222
CC	IF(PLT.EQ.-3)GO TO 2422
C  FOR 2-PASS PLOTTING (-2=THIN LINES, -3=HEAVY LINES)
	X=NACCI(JE)
CC	IF(PLT.EQ.-2)PLT=-4
	CALL RDRAW(X+1,RACCI(X),RACCI,RMINI,RJB,CENTR,RMINI)
CC	IF(PLT.EQ.-4)PLT=-2
	GO TO 2422

500	RJB=RJB-RST3
	JJB=JJB-RSTJC*13.
C   ADJUSTS POS. OF #S
	JE=JE-1
	GO TO 222
C NUMBERS.  5, POS, STF, NOTE #, NUM, SIZE(DECI'S)
50	RDIS=RJE
	JJJ=JF
	IF(RDIS.EQ.0)RDIS=1.
	PUNCT=0
	IF(JJJ.LT.44)GO TO 51
	PUNCT=JJJ
	IF(JJJ.EQ.44)JJJ=38
	IF(JJJ.GE.45)JJJ=36
	IF(JF.NE.46)GO TO 51
	RXX=4
	RJB=RJB-RXX*RSTJC
	RX=16
	CENTR=CENTR+RX*RSTJC
51	RX=RDIS*RSTJC
451	X=NUMQ(JJJ+1)
C  X=END # OF ITEM
C  X+1=1ST PART OF ITEM
      CALL RDRAW(X+1,RNUMS(X),RNUMS,RX,RJB,CENTR+RST3,RX)
	IF(PUNCT.EQ.0)GO TO 151
	IF(PUNCT.NE.46)GO TO 351
	RJB=RJB+2*RXX*RSTJC
C  FOR "
651	PUNCT=0
	GO TO 451
351	RXX=11
C FOR : AND ;
	CENTR=CENTR+RXX*RSTJC
	JJJ=38
	GO TO 651
151	IF(JA.EQ.101)GO TO 1005
	RETURN

110	JC=RJB
	IF(JC.NE.99)GO TO 1008
	CALL HYDPOG(2)
	RETURN
1008	JF=0
	JE=0
	RSTJC=1.
C  SETS UP SCALE LINES.
	RJC=STFF(JC+4)+60 
	RJ=RJC+60
	CENTR=RJC+74
	CALL DPYSET(2,SU,250)
	CALL DPYBRT(1)
1001	POS=RJC+64
	DO 1002 MX=10,200,10
	RA=RHORZ(FLOAT(MX))
	RJB=RA-58
	IF(MX.GT.10)GO TO 50
1005	IF(RJE.NE.0)GO TO 1007
C  JUMP FOR STAFF NUMBERS
	CALL LINES(RA,RJC,3)
	CALL LINES(RA,RJ,2)
	JF=JF+1
1002	IF(JF.EQ.10)JF=0
	CALL LINES(-596.0,RJ,2)
	CALL LINES(-596.0,RJC,2)
	RJE=1.5
C  NEXT SETS UP STAFF NUMBERS
	RJB=-620.
	DO 1007 K=-3,4
	CENTR=STFF(K+4)+21.
	JF=IABS(K)
	GO TO 50
1007	CONTINUE
	CALL DPYOUT(2)
	CALL SETPOG(1)
	RETURN

C  FOR 1 OR 2 BAR REP SIGNS.
60	CALL BREP(RJB,RSTJC)
	END